home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / calculat.pas < prev    next >
Pascal/Delphi Source File  |  1985-06-03  |  14KB  |  581 lines
  1.   { TURN ON RECURSION ABILITY, MUST BE FIRST LINE IN PASCAL/MT+    }
  2.   { TURN ON RUN-TIME ERROR CHECKING                }
  3.  
  4. PROGRAM HANDCALC ;
  5.  
  6. {   THIS PROGRAM IS INTENDED TO ACT AS A SCIENTIFIC CALCULATOR, WITH    }
  7. {   EXPONENTIATION AND TRANCENDENTAL FUNCTIONS.                }
  8.  
  9. CONST
  10.     FUNC_LEN  = 6;    { NO. OF CHARACTERS ALLOWED IN A FUNCTION NAME    }
  11.     NUM_FUNCS = 20;    { NO. OF FUNCTIONS RECOGNIZED            }
  12.     PI        = 3.1415926535897323846264338; { THIS IS SILLY OF COURSE }
  13.                         { BUT THE NUMBERS ARE CORRECT }
  14.  
  15. TYPE
  16.     FUNCTIONS = (ARCTANGENT, COSINE, LOGRITHM, SINE, SQUARE, SQUARE_ROOT,
  17.             EXPONENT, TANGENT, COTANGENT, SECANT, COSECANT,
  18.             ARCSINE, ARCCOSINE, ARCCOTANGENT, ARCSECANT,
  19.             ARCCOSECANT, PIE, RADIANS, LOG, FACTORIAL,
  20.             NON_FUNCTION);
  21.  
  22.     SET_OF_FUNCS = SET OF FUNCTIONS;
  23.     FUNC_NAME = ARRAY [1..FUNC_LEN] OF CHAR;
  24.     FUNC_REC  = RECORD
  25.             NAME    : FUNC_NAME;
  26.             FUNC_TYPE : FUNCTIONS
  27.             END;
  28.     FUNC_LIST = ARRAY [1..NUM_FUNCS] OF FUNC_REC;
  29.  
  30. VAR
  31.     ANSWER        : REAL;
  32.     BUF        : STRING[80];
  33.     Z        : INTEGER;    { INDEX INTO BUF }
  34.     F_NAMES        : FUNC_LIST;
  35.     NON_PARM_FUNCS    : SET_OF_FUNCS;
  36.     DEBUG_MODE    : BOOLEAN;
  37.  
  38. PROCEDURE SCREENCLR;
  39.  
  40.     VAR
  41.         I : INTEGER;
  42.  
  43.     BEGIN { SCREENCLR }
  44.     { IF YOUR TERMINAL CAN CLEAR THE SCREEN (WITH SAY A CONTROL-Z) THEN }
  45.     { OUTPUT WHAT EVER CHARACTERS ARE NEEDED IN PLACE OF THIS LOOP      }
  46.  
  47.     FOR I := 1 TO 24 DO
  48.         WRITELN
  49.  
  50.     END;  { SCREENCLR }
  51. FUNCTION SKIP_LINE (N : INTEGER) : CHAR;
  52.  
  53.     VAR
  54.     I : INTEGER;
  55.  
  56.     BEGIN { SKIP_LINE }
  57.     FOR I := 1 TO N DO
  58.     WRITELN;
  59.     SKIP_LINE := CHR(0)
  60.     END;  { SKIP_LINE }
  61. PROCEDURE INITIALIZATION;
  62.  
  63.      VAR
  64.     I : INTEGER;
  65.  
  66.      PROCEDURE INIT_FUNCS;
  67.  
  68.     BEGIN { INIT_FUNCS }
  69.         { THE ORDER OF THE STRINGS IN F_NAMES MUST BE ALPHABETICAL }
  70.         { THIS SHOULD BE REMEMBERED WHEN ADDING NEW FUNCTIONS       }
  71.     F_NAMES[1].NAME := 'ARCCOS';    F_NAMES[1].FUNC_TYPE := ARCCOSINE;
  72.     F_NAMES[2].NAME := 'ARCCOT';    F_NAMES[2].FUNC_TYPE := ARCCOTANGENT;
  73.     F_NAMES[3].NAME := 'ARCCSC';    F_NAMES[3].FUNC_TYPE := ARCCOSECANT;
  74.     F_NAMES[4].NAME := 'ARCSEC';    F_NAMES[4].FUNC_TYPE := ARCSECANT;
  75.     F_NAMES[5].NAME := 'ARCSIN';    F_NAMES[5].FUNC_TYPE := ARCSINE;
  76.     F_NAMES[6].NAME := 'ARCTAN';    F_NAMES[6].FUNC_TYPE := ARCTANGENT;
  77.     F_NAMES[7].NAME := 'COS   ';    F_NAMES[7].FUNC_TYPE := COSINE;
  78.     F_NAMES[8].NAME := 'COT   ';    F_NAMES[8].FUNC_TYPE := COTANGENT;
  79.     F_NAMES[9].NAME := 'CSC   ';    F_NAMES[9].FUNC_TYPE := COSECANT;
  80.     F_NAMES[10].NAME:= 'EXP   ';    F_NAMES[10].FUNC_TYPE:= EXPONENT;
  81.     F_NAMES[11].NAME:= 'FACTOR';    F_NAMES[11].FUNC_TYPE:= FACTORIAL;
  82.     F_NAMES[12].NAME:= 'LN    ';    F_NAMES[12].FUNC_TYPE:= LOGRITHM;
  83.     F_NAMES[13].NAME:= 'LOG   ';    F_NAMES[13].FUNC_TYPE:= LOG;
  84.     F_NAMES[14].NAME:= 'PI    ';    F_NAMES[14].FUNC_TYPE:= PIE;
  85.     F_NAMES[15].NAME:= 'RADIAN';    F_NAMES[15].FUNC_TYPE:= RADIANS;
  86.     F_NAMES[16].NAME:= 'SEC   ';    F_NAMES[16].FUNC_TYPE:= SECANT;
  87.     F_NAMES[17].NAME:= 'SIN   ';    F_NAMES[17].FUNC_TYPE:= SINE;
  88.     F_NAMES[18].NAME:= 'SQR   ';    F_NAMES[18].FUNC_TYPE:= SQUARE;
  89.     F_NAMES[19].NAME:= 'SQRT  ';    F_NAMES[19].FUNC_TYPE:= SQUARE_ROOT;
  90.     F_NAMES[20].NAME:= 'TAN   ';    F_NAMES[20].FUNC_TYPE:= TANGENT;
  91.     NON_PARM_FUNCS := [PIE]
  92.     END;  { INIT_FUNCS }
  93.  
  94.      BEGIN { INITIALIZATION }
  95.         { CLEAR THE SCREEN }
  96.      SCREENCLR;
  97.      WRITELN ('CALCULATOR');
  98.      WRITELN;
  99.      WRITELN ('BY WARREN A. SMITH  --  JULY 29, 1981');
  100.      WRITE (SKIP_LINE(4));
  101.      WRITELN ('A ''?'' AT THE BEGINNING OF A LINE WILL BRING UP A LISTING');
  102.      WRITELN ('  OF POSSIBLE FUNCTIONS AND OPERATORS THAT MAY BE USED.');
  103.      WRITELN;
  104.      WRITELN ('A DOLLAR SIGN ''$'' AT THE BEGINNING OF A LINE WILL');
  105.      WRITELN ('  CAUSE THIS PROGRAM TO TERMINATE.');
  106.      WRITELN;
  107.      DEBUG_MODE := FALSE;
  108.      INIT_FUNCS
  109.      END;  { INITIALIZATION }
  110.  
  111.  
  112.  
  113. FUNCTION TAB (N : INTEGER) : CHAR;
  114.  
  115.     VAR
  116.     I : INTEGER;
  117.  
  118.     BEGIN { TAB }
  119.     FOR I := 1 TO N DO
  120.     WRITE (' ')
  121.     END;  { TAB }
  122.  
  123. FUNCTION UPPER (IN_CHAR : CHAR) : CHAR;
  124.  
  125.      BEGIN { UPPER }
  126.      IF (IN_CHAR >= 'a') AND (IN_CHAR <= 'z') THEN
  127.          UPPER := CHR(ORD(IN_CHAR) + (ORD('A') - ORD('a')))
  128.      ELSE
  129.          UPPER := IN_CHAR
  130.      END;  { UPPER }
  131.  
  132. PROCEDURE HELP;
  133.  
  134.     VAR
  135.     RESPONSE : CHAR;
  136.  
  137.     BEGIN { HELP }
  138.      SCREENCLR;
  139.      WRITELN ('  THE CURRENTLY AVAILABLE FUNCTIONS ARE :');
  140.      WRITELN;
  141.      WRITELN ('    ARCCOSINE   - ARCCOS    ARCCOTANGENT     - ARCCOT');
  142.      WRITELN ('    ARCCOSECANT - ARCCSC    ARCSECANT        - ARCSEC');
  143.      WRITELN ('    ARCSINE     - ARCSIN    ARCTANGENT       - ARCTAN');
  144.      WRITELN ('    COSINE      - COS       COTANGENT        - COT   ');
  145.      WRITELN ('    COSECANT    - CSC       NATURAL EXPONENT - EXP   ');
  146.      WRITELN ('    NATURAL LOG - LN        SECANT           - SEC   ');
  147.      WRITELN ('    SINE        - SIN       SQUARE           - SQR   ');
  148.      WRITELN ('    SQUARE ROOT - SQRT      TANGENT          - TAN   ');
  149.      WRITELN ('    LOG BASE 10 - LOG       FACTORIAL        - FACTOR');
  150.      WRITELN ('    VALUE OF PI - PI                    ');
  151.      WRITELN;
  152.      WRITELN ('  ALLOWABLE OPERATORS ARE:');
  153.      WRITELN ('      ''+'', ''-'', ''*'', ''/'', AND ''^'' (EXPONENTIATION)');
  154.      WRITELN;
  155.      WRITELN ('  UPPER CASE AND LOWER CASE ARE IRRELEVANT IN FUNCTION NAMES');
  156.      WRITELN ('  A ''$'' WILL END THE PROGRAM, A ''!'' TURNS ON DEBUG MODE ');
  157.      WRITELN;
  158.      WRITELN ('HIT THE CARRIAGE RETURN TO PROCEED.');
  159.      READ (RESPONSE);
  160.     END;  { HELP }
  161.  
  162. FUNCTION EOLN : BOOLEAN;
  163.  
  164.     BEGIN { EOLN }
  165.     EOLN := Z > LENGTH(BUF)
  166.     END;  { EOLN }
  167.  
  168. PROCEDURE SLOUGH_BLANKS;
  169.  
  170.     BEGIN { SLOUGH_BLANKS }
  171.     WHILE (BUF[Z] = ' ') AND (NOT EOLN) DO
  172.        Z := Z + 1
  173.     END;  { SLOUGH_BLANKS }
  174.  
  175. PROCEDURE GET_EXPR;
  176.  
  177.     BEGIN { GET_EXPR }
  178.     REPEAT
  179.     WRITELN;
  180.     WRITELN ('TYPE IN AN EXPRESSION TO BE SOLVED.');
  181.     READLN (BUF);
  182.     Z := 1;
  183.     SLOUGH_BLANKS
  184.     UNTIL NOT EOLN
  185.     END;  { GET_EXPR }
  186.  
  187. FUNCTION EXPR : REAL;
  188.  
  189.      VAR
  190.     UNARY,
  191.     ANSWER    : REAL;
  192.  
  193.      FUNCTION TERM : REAL;
  194.  
  195.     VAR
  196.         ANSWER    : REAL;
  197.  
  198.     FUNCTION EXPON : REAL;
  199.  
  200.         VAR
  201.         ANSWER : REAL;
  202.  
  203.         FUNCTION XTOY (X, Y : REAL) : REAL;
  204.  
  205.         BEGIN { XTOY }
  206.         IF X >= 0.0 THEN
  207.             XTOY := EXP(Y * LN(X))
  208.         ELSE
  209.             XTOY := 0.0
  210.         END;  { XTOY }
  211.  
  212.         FUNCTION FACTOR : REAL;
  213.  
  214.            VAR
  215.             ANSWER,
  216.             X    : REAL;
  217.             FUNC    : FUNCTIONS;
  218.         FUNCTION DIGIT (IN_CHAR : CHAR) : BOOLEAN ;
  219.  
  220.              BEGIN { DIGIT }
  221.              DIGIT := IN_CHAR IN ['0','1','2','3','4','5','6','7',
  222.                       '8','9']
  223.              END;  { DIGIT }
  224.         PROCEDURE READ (VAR ANSWER : REAL);
  225.  
  226.              VAR
  227.             FACT_POWER : REAL;
  228.  
  229.              BEGIN { READ }
  230.              ANSWER := 0.0;
  231.              SLOUGH_BLANKS;
  232.              WHILE DIGIT (BUF[Z]) AND NOT EOLN DO
  233.             BEGIN
  234.             ANSWER := ANSWER * 10.0 + (ORD(BUF[Z])-ORD('0'));
  235.             Z := Z + 1
  236.             END;
  237.              IF (BUF[Z] = '.') AND NOT EOLN THEN
  238.             BEGIN
  239.             Z := Z + 1;
  240.             FACT_POWER := 1.0;
  241.             WHILE DIGIT (BUF[Z]) AND NOT EOLN DO
  242.                 BEGIN
  243.                 FACT_POWER := FACT_POWER / 10.0;
  244.                 ANSWER := ANSWER+(ORD(BUF[Z])-ORD('0'))*FACT_POWER;
  245.                 Z := Z + 1
  246.                 END
  247.             END
  248.              END;  { READ }
  249.  
  250.  
  251.  
  252.         FUNCTION LETTER (VAR IN_CHAR : CHAR) : BOOLEAN;
  253.  
  254.              BEGIN { LETTER }
  255.              IN_CHAR := UPPER (IN_CHAR);
  256.              LETTER := IN_CHAR IN ['A','B','C','D','E','F','G','H',
  257.                        'I','J','K','L','M','N','O','P',
  258.                        'Q','R','S','T','U','V','W','X',
  259.                        'Y','Z']
  260.              END;  { LETTER }
  261.  
  262.         FUNCTION GET_FUNC_TYPE : FUNCTIONS;
  263.  
  264.              VAR
  265.             ID : FUNC_NAME;
  266.             INDEX : INTEGER;
  267.  
  268.              FUNCTION SEARCH_FUNCS (ID : FUNC_NAME) : FUNCTIONS;
  269.  
  270.               VAR
  271.                 I, J, K    : INTEGER;
  272.  
  273.               BEGIN { SEARCH_FUNCS }
  274.               I := 1;
  275.                J := NUM_FUNCS;
  276.               REPEAT
  277.                    K := (I+J) DIV 2;      { BINARY SEARCH }
  278.                    WITH F_NAMES[K] DO
  279.                    BEGIN
  280.                    IF NAME <= ID  THEN
  281.                     I := K+1;
  282.  
  283.                    IF NAME >= ID THEN
  284.                     J := K-1
  285.                    END
  286.  
  287.               UNTIL I > J;
  288.                IF F_NAMES[K].NAME <> ID THEN
  289.                    SEARCH_FUNCS := NON_FUNCTION
  290.               ELSE
  291.                    SEARCH_FUNCS := F_NAMES[K].FUNC_TYPE
  292.               END;  { SEARCH_FUNCS }
  293.  
  294.              BEGIN { GET_FUNC_TYPE }
  295.              INDEX := 1;
  296.              REPEAT
  297.               ID [INDEX] := BUF[Z];
  298.               Z := Z + 1;
  299.               INDEX := INDEX + 1
  300.              UNTIL NOT LETTER(BUF[Z]) OR EOLN OR (INDEX > FUNC_LEN);
  301.              WHILE INDEX <= FUNC_LEN DO
  302.               BEGIN
  303.               ID [INDEX] := ' ';
  304.               INDEX := INDEX + 1
  305.               END;
  306.  
  307.              GET_FUNC_TYPE := SEARCH_FUNCS (ID)
  308.              END;  { GET_FUNC_TYPE }
  309.  
  310.         FUNCTION TAN (X : REAL) : REAL;
  311.  
  312.             BEGIN { TAN }
  313.             TAN := SIN(X) / COS(X)
  314.             END;  { TAN }
  315.  
  316.         FUNCTION COT (X : REAL) : REAL;
  317.  
  318.             BEGIN { COT }
  319.             COT := COS(X) / SIN(X)
  320.             END;  { COT }
  321.  
  322.         FUNCTION SEC (X : REAL) : REAL;
  323.  
  324.             BEGIN { SEC }
  325.             SEC := 1.0 / COS(X)
  326.             END;  { SEC }
  327.  
  328.         FUNCTION CSC (X : REAL) : REAL;
  329.  
  330.             BEGIN { CSC }
  331.             CSC := 1.0 / SIN(X)
  332.             END;  { CSC }
  333.  
  334.         FUNCTION ARCSIN (X : REAL) : REAL;
  335.  
  336.             BEGIN { ARCSIN }
  337.             ARCSIN := ARCTAN(X / SQRT(1.0 - SQR(X)))
  338.             END;  { ARCSIN }
  339.  
  340.         FUNCTION ARCCOS (X : REAL) : REAL;
  341.  
  342.             BEGIN { ARCCOS }
  343.             ARCCOS := PI / 2.0 - ARCTAN (X / SQRT(1.0 - SQR(X)))
  344.             END;  { ARCCOS }
  345.  
  346.         FUNCTION ARCCOT (X : REAL) : REAL;
  347.  
  348.             BEGIN { ARCCOT }
  349.             ARCCOT := PI / 2.0 - ARCTAN (X)
  350.             END;  { ARCCOT }
  351.  
  352.         FUNCTION ARCSEC (X : REAL) : REAL;
  353.  
  354.             BEGIN { ARCSEC }
  355.             ARCSEC := ARCTAN (SQRT(SQR(X) - 1.0))
  356.             END;  { ARCSEC }
  357.  
  358.         FUNCTION ARCCSC (X : REAL) : REAL;
  359.  
  360.             BEGIN { ARCCSC }
  361.             ARCCSC := ARCTAN (1.0 / SQRT(SQR(X) - 1.0))
  362.             END;  { ARCCSC }
  363.  
  364.         FUNCTION RADIAN (X : REAL) : REAL;
  365.  
  366.             BEGIN { RADIAN }
  367.             RADIAN := X * (PI / 180.0)
  368.             END;  { RADIAN }
  369.  
  370.         FUNCTION LOG10 (X : REAL) : REAL;
  371.  
  372.             BEGIN { LOG10 }
  373.             LOG10 := LN(X) / LN(10.0)
  374.             END;  { LOG10 }
  375.  
  376.         FUNCTION FACTORL (X : REAL) : REAL;
  377.  
  378.             VAR
  379.             INT_X, I    : INTEGER;
  380.             PRODUCT        : REAL;
  381.  
  382.             BEGIN { FACTORL }
  383.             INT_X := ROUND(X);
  384.             IF INT_X = 0 THEN
  385.             FACTORL := 1.0
  386.             ELSE
  387.             BEGIN
  388.             PRODUCT := 1.0;
  389.             FOR I := 2 TO INT_X DO
  390.                 PRODUCT := PRODUCT * I;
  391.             FACTORL := PRODUCT
  392.             END
  393.             END;  { FACTORL }
  394.  
  395.         BEGIN { FACTOR }
  396.         SLOUGH_BLANKS;
  397.         IF DIGIT (BUF[Z]) OR (BUF[Z] = '.') THEN
  398.              READ (ANSWER)
  399.         ELSE
  400.              IF BUF[Z] = '(' THEN
  401.               BEGIN
  402.               Z := Z + 1;
  403.               ANSWER := EXPR;
  404.               IF BUF[Z] <> ')' THEN
  405.                 BEGIN
  406.                 WRITE (TAB(Z-1),'^ ');
  407.                 WRITELN ('*** '')'' EXPECTED')
  408.                 END
  409.               ELSE
  410.                 Z := Z + 1
  411.               END
  412.              ELSE
  413.               IF LETTER (BUF[Z]) THEN
  414.                 BEGIN
  415.                 FUNC := GET_FUNC_TYPE;
  416.                 SLOUGH_BLANKS;
  417.                 IF NOT (FUNC IN NON_PARM_FUNCS) THEN
  418.                     BEGIN
  419.                     IF BUF[Z] = '(' THEN
  420.                     BEGIN
  421.                     Z := Z + 1;
  422.                     ANSWER := EXPR
  423.                     END
  424.                     ELSE
  425.                     BEGIN
  426.                     WRITE (TAB(Z-1), '^ ');
  427.                     WRITE ('*** ''('' EXPECTED, ANSWER ');
  428.                     WRITELN ('MAY BE IN ERROR')
  429.                     END;
  430.                     SLOUGH_BLANKS;
  431.                     IF BUF[Z] = ')' THEN
  432.                     Z := Z + 1
  433.                     ELSE
  434.                     BEGIN
  435.                     WRITE (TAB(Z-1), '^ ');
  436.                     WRITE ('*** '')'' EXPECTED, ANSWER ');
  437.                     WRITELN ('MAY BE IN ERROR')
  438.                     END
  439.                     END;
  440.                 CASE FUNC OF
  441.                     LOGRITHM    : ANSWER := LN (ANSWER);
  442.                     EXPONENT    : ANSWER := EXP (ANSWER);
  443.                     LOG        : ANSWER := LOG10 (ANSWER);
  444.                     SQUARE      : ANSWER := SQR (ANSWER);
  445.                     SQUARE_ROOT : ANSWER := SQRT (ANSWER);
  446.                     FACTORIAL    : ANSWER := FACTORL (ANSWER);
  447.                     COSINE    : ANSWER :=
  448.                             COS (RADIAN(ANSWER));
  449.                     SINE    : ANSWER :=
  450.                             SIN (RADIAN(ANSWER));
  451.                     ARCTANGENT  : ANSWER :=
  452.                                ARCTAN (RADIAN(ANSWER));
  453.                     TANGENT    : ANSWER :=
  454.                              TAN (RADIAN(ANSWER));
  455.                     COTANGENT   : ANSWER :=
  456.                              COT (RADIAN(ANSWER));
  457.                     SECANT    : ANSWER :=
  458.                              SEC (RADIAN(ANSWER));
  459.                     COSECANT    : ANSWER :=
  460.                              COS (RADIAN(ANSWER));
  461.                     ARCSINE    : ANSWER :=
  462.                                ARCSIN (RADIAN(ANSWER));
  463.                     ARCCOSINE   : ANSWER :=
  464.                                ARCCOS (RADIAN(ANSWER));
  465.                     ARCCOTANGENT: ANSWER :=
  466.                                ARCCOT (RADIAN(ANSWER));
  467.                     ARCSECANT   : ANSWER :=
  468.                                ARCSEC (RADIAN(ANSWER));
  469.                     ARCCOSECANT : ANSWER :=
  470.                             ARCCSC (ANSWER);
  471.                     PIE        : ANSWER := PI;
  472.                     RADIANS    : ANSWER := RADIAN (ANSWER);
  473.                     NON_FUNCTION: BEGIN
  474.                           WRITE (TAB(Z-1), '^ ');
  475.                           WRITELN
  476.                         ('*** UNINOWN FUNCTION NAME')
  477.                           END
  478.                     END; { CASE }
  479.                 SLOUGH_BLANKS
  480.                 END
  481.               ELSE
  482.                 BEGIN
  483.                 WRITE (TAB(Z-1), '^ ');
  484.                 WRITE ('*** UNKNOWN SYNTAX, ANSWER MAY ');
  485.                 WRITELN ('BE IN ERROR')
  486.                 END;
  487.         IF DEBUG_MODE THEN
  488.             WRITELN ('RESULT FROM FACTOR = ', ANSWER:20:8);
  489.         FACTOR := ANSWER
  490.         END;  { FACTOR }
  491.  
  492.         BEGIN { EXPON }
  493.         ANSWER := FACTOR;
  494.         SLOUGH_BLANKS;
  495.         WHILE BUF[Z] = '^' DO
  496.         BEGIN
  497.         Z := Z + 1;
  498.         ANSWER := XTOY (ANSWER, FACTOR);
  499.         SLOUGH_BLANKS
  500.         END;
  501.         IF DEBUG_MODE THEN
  502.         WRITELN ('RESULT FROM EXPON = ', ANSWER:20:8);
  503.         EXPON := ANSWER
  504.         END;  { EXPON }
  505.  
  506.       BEGIN { TERM }
  507.       ANSWER := EXPON;
  508.       SLOUGH_BLANKS;
  509.       WHILE BUF[Z] IN ['*', '/'] DO
  510.         BEGIN
  511.         IF BUF[Z] = '*' THEN
  512.              BEGIN
  513.              Z := Z + 1;
  514.              ANSWER := ANSWER * EXPON
  515.              END
  516.         ELSE
  517.              BEGIN
  518.              Z := Z + 1;
  519.              ANSWER := ANSWER / EXPON;
  520.              END;
  521.         SLOUGH_BLANKS
  522.         END;
  523.       IF DEBUG_MODE THEN
  524.         WRITELN ('RESULT FROM TERM = ', ANSWER:20:8);
  525.       TERM := ANSWER
  526.       END;  { TERM }
  527.  
  528.      BEGIN { EXPR }
  529.      SLOUGH_BLANKS;
  530.      UNARY := 1.0;
  531.      IF BUF[Z] IN ['+','-'] THEN
  532.     BEGIN
  533.     IF BUF[Z] = '-' THEN
  534.         UNARY := -1.0;
  535.     Z := Z + 1
  536.     END;
  537.      ANSWER := UNARY * TERM;
  538.      SLOUGH_BLANKS;
  539.      WHILE BUF[Z] IN ['+', '-'] DO
  540.     BEGIN
  541.     IF BUF[Z] = '+' THEN
  542.         BEGIN
  543.         Z := Z + 1;
  544.         ANSWER := ANSWER + TERM
  545.         END
  546.     ELSE
  547.         BEGIN
  548.         Z := Z + 1;
  549.         ANSWER := ANSWER - TERM
  550.         END;
  551.     SLOUGH_BLANKS
  552.     END;
  553.      IF DEBUG_MODE THEN
  554.     WRITELN ('RESULT FROM EXPR =', ANSWER:20:8);
  555.      EXPR := ANSWER
  556.      END;  { EXPR }
  557.  
  558. BEGIN { MAIN }
  559. INITIALIZATION;
  560. GET_EXPR;
  561. WHILE BUF[Z] <> '$' DO
  562.      BEGIN
  563.      IF BUF[Z] = '?' THEN
  564.     HELP
  565.      ELSE
  566.     IF BUF[Z] = '!' THEN
  567.         DEBUG_MODE := NOT DEBUG_MODE
  568.     ELSE
  569.         IF BUF[Z] <> '$' THEN
  570.         BEGIN
  571.         ANSWER := EXPR;
  572.         WRITELN;
  573.         WRITELN ('THE ANSWER IS :', ANSWER:9:6)
  574.         END;
  575.      GET_EXPR
  576.      END;
  577. WRITELN;
  578. WRITELN ('PROGRAM ENDED');
  579. WRITELN
  580. END.
  581.